home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Magnum One
/
Magnum One (Mid-American Digital) (Disc Manufacturing).iso
/
d18
/
tw200d.arc
/
TD200.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1990-05-08
|
18KB
|
599 lines
{
TW200 VIDEO, WINDOW AND MENU PROCEDURES AND FUNCTIONS
TURBO PASCAL VERSION 5.X DEMONSTRATION PROGRAM
COPYRIGHT (C) 1990, RICHARD D. FOTHERGILL ALL RIGHTS RESERVED
}
USES
Dos,
Crt,
TW200;
VAR
mmenu : hmenurec;
smenu : vmenurec;
emenu : vmenurec;
done : BOOLEAN;
menunoattr : INTEGER;
curattr : INTEGER;
x : INTEGER;
msg,msg1 : STRING[80];
ch : CHAR;
PROCEDURE Initmenus;
BEGIN
menunoattr := Attr(8,7);
winspeed := 3500;
WITH mmenu DO
BEGIN
curntpos := 0;
item[1] := 'Frames';
item[2] := 'Titles';
item[3] := 'Shadows';
item[4] := 'Demos';
item[5] := 'Quit';
itemcount := 5;
startpos := 1;
hlattr := Attr(7,0);
flattr := Attr(15,7);
flon := TRUE;
menuspaces := 8;
barloc := 0;
subitem :='00110';
END;
WITH smenu DO
BEGIN
startpos := 0;
liveitem := '11011011';
curntpos := 0;
item[1] := 'Flat ( 0)';
item[2] := 'Reattribute (1, 2)';
item[3] := 'Solid (3, 4)';
item[4] := 'Light Hatch (5, 6)';
item[5] := 'Medium Hatch (7, 8)';
item[6] := 'Heavy Hatch (9,10)';
item[7] := 'Activate Items 3,6 ';
item[8] := 'Deact. Items 3,6 ';
itemcount := 8;
hlattr := Attr(7,0);
flattr := Attr(15,7);
noattr := menunoattr;
bartype := 1;
flon := TRUE;
END;
WITH emenu DO
BEGIN
startpos := 0;
liveitem := '11111';
curntpos := 0;
item[1] := 'Pop Windows ';
item[2] := 'Zoom Windows ';
item[3] := 'List / File Window';
item[4] := 'DOS Utilities ';
item[5] := 'Field Input ';
itemcount := 5;
hlattr := Attr(7,0);
flattr := Attr(15,7);
noattr := menunoattr;
bartype := 1;
flon := TRUE;
END;
END;
PROCEDURE Continue;
VAR
ch1,ch2 : CHAR;
BEGIN
Sprintc(25,1,80,' Press any key to continue... ',Attr(15,3));
REPEAT
Getkey(ch1,ch2);
UNTIL ch1 <> #0;
Sprintc(25,1,80,'Use arrow keys to change selection - Return to select',Attr(0,3));
END;
PROCEDURE Fdemo;
BEGIN
Openwin(5,15,6,15,Attr(15,2),Attr(15,2),0,0,1,0);
Titlewin(2,Attr(14,2),'[ Style 0 ]');
Openwin(5,34,6,15,Attr(15,5),Attr(15,5),1,7,1,0);
Titlewin(2,Attr(14,5),'[ Style 1 ]');
Openwin(5,53,6,15,Attr(15,3),Attr(15,3),2,7,1,0);
Titlewin(2,Attr(14,3),'[ Style 2 ]');
Openwin(8,5,6,15,Attr(15,4),Attr(15,4),3,7,1,0);
Titlewin(2,Attr(14,4),'[ Style 3 ]');
Openwin(8,24,6,15,Attr(15,3),Attr(15,3),4,7,1,0);
Titlewin(2,Attr(14,3),'[ Style 4 ]');
Openwin(8,43,6,15,Attr(15,6),Attr(15,6),5,7,1,0);
Titlewin(2,Attr(14,6),'[ Style 5 ]');
Openwin(8,62,6,15,Attr(15,5),Attr(15,5),6,7,1,0);
Titlewin(2,Attr(14,5),'[ Style 6 ]');
Openwin(11,15,6,15,Attr(15,2),Attr(15,2),7,7,1,0);
Titlewin(2,Attr(14,2),'[ Style 7 ]');
Openwin(11,34,6,15,Attr(15,7),Attr(15,7),8,7,1,0);
Titlewin(2,Attr(14,7),'[ Style 8 ]');
Openwin(11,53,6,15,Attr(15,4),Attr(15,4),9,7,1,0);
Titlewin(2,Attr(14,4),'[ Style 9 ]');
Openwin(14,5,6,15,Attr(15,7),Attr(15,7),10,7,1,0);
Titlewin(2,Attr(14,7),'[ Style 10]');
Openwin(14,24,6,15,Attr(15,6),Attr(15,6),11,7,1,0);
Titlewin(2,Attr(14,6),'[ Style 11]');
Openwin(14,43,6,15,Attr(15,5),Attr(15,5),12,7,1,0);
Titlewin(2,Attr(14,5),'[ Style 12]');
Openwin(14,62,6,15,Attr(15,2),Attr(15,2),13,7,1,0);
Titlewin(2,Attr(14,2),'[ Style 13]');
Openwin(17,15,6,15,Attr(15,3),Attr(15,3),14,7,1,0);
Titlewin(2,Attr(14,3),'[ Style 14]');
Openwin(17,34,6,15,Attr(15,2),Attr(15,2),15,7,1,0);
Titlewin(2,Attr(14,2),'[ Style 15]');
Openwin(17,53,6,15,Attr(15,7),Attr(15,7),16,7,1,0);
Titlewin(2,Attr(14,7),'[ Style 16]');
Continue;
FOR x := 1 TO 17 DO Closewin;
END;
PROCEDURE Tdemo;
BEGIN
Openwin(8,8,10,68,Attr(15,5),Attr(15,5),2,0,1,0);
Printcwin(3,'Titles may be placed in any of six different locations');
Printcwin(4,'and in any color attribute!');
FOR x:=1 TO 6 DO
BEGIN
STR(x,msg);
msg := '[ LOCATION '+msg+' ]';
Titlewin(x,Attr(9+x,5),msg);
DELAY(1000);
END;
Continue;
Closewin;
END;
PROCEDURE Sdemo;
BEGIN
Openwin(2,32,10,23,Attr(0,7),Attr(0,7),1,8,1,0);
done := FALSE;
WITH smenu DO
BEGIN
WHILE NOT done DO
BEGIN
Makevmenu(smenu);
CASE curntpos OF
1 : BEGIN
Openwin(10,4,7,74,Attr(15,5),Attr(15,5),2,0,0,0);
Titlewin(2,Attr(15,5),' FLAT ');
Openwin(11,8,10,30,Attr(15,3),Attr(0,3),1,0,0,0);
Openwin(11,43,10,30,Attr(15,7),Attr(1,7),1,0,0,0);
Continue;
Closewin;
Closewin;
Closewin;
END;
2 : BEGIN
Openwin(10,4,7,74,Attr(15,5),Attr(15,5),2,0,0,0);
Titlewin(2,Attr(15,5),' REATTRIBUTE ');
Openwin(11,8,10,30,Attr(15,3),Attr(0,3),2,7,1,0);
Printcwin(7,'Left Shadow');
Openwin(11,43,10,30,Attr(15,7),Attr(1,7),2,7,2,0);
Printcwin(7,'Right Shadow');
Continue;
Closewin;
Closewin;
Closewin;
END;
3 : BEGIN
Openwin(10,4,7,74,Attr(15,5),Attr(15,5),2,0,0,0);
Titlewin(2,Attr(15,5),' SOLID ');
Openwin(11,8,10,30,Attr(15,3),Attr(0,3),2,0,3,0);
Printcwin(7,'Left Shadow');
Openwin(11,43,10,30,Attr(15,7),Attr(1,7),2,0,4,0);
Printcwin(7,'Right Shadow');
Continue;
Closewin;
Closewin;
Closewin;
END;
4 : BEGIN
Openwin(10,4,7,74,Attr(15,5),Attr(15,5),2,0,0,0);
Titlewin(2,Attr(15,5),' LT. HATCH ');
Openwin(11,8,10,30,Attr(15,3),Attr(0,3),2,Attr(0,7),5,0);
Printcwin(7,'Left Shadow');
Openwin(11,43,10,30,Attr(15,7),Attr(1,7),2,Attr(0,7),6,0);
Printcwin(7,'Right Shadow');
Continue;
Closewin;
Closewin;
Closewin;
END;
5 : BEGIN
Openwin(10,4,7,74,Attr(15,5),Attr(15,5),2,0,0,0);
Titlewin(2,Attr(15,5),' MED. HATCH ');
Openwin(11,8,10,30,Attr(15,3),Attr(0,3),2,Attr(0,7),7,0);
Printcwin(7,'Left Shadow');
Openwin(11,43,10,30,Attr(15,7),Attr(1,7),2,Attr(0,7),8,0);
Printcwin(7,'Right Shadow');
Continue;
Closewin;
Closewin;
Closewin;
END;
6 : BEGIN
Openwin(10,4,7,74,Attr(15,5),Attr(15,5),2,0,0,0);
Titlewin(2,Attr(15,5),' HEAVY HATCH ');
Openwin(11,8,10,30,Attr(15,3),Attr(0,3),2,Attr(0,7),9,0);
Printcwin(7,'Left Shadow');
Openwin(11,43,10,30,Attr(15,7),Attr(1,7),2,Attr(0,7),10,0);
Printcwin(7,'Right Shadow');
Continue;
Closewin;
Closewin;
Closewin;
END;
7 : BEGIN
liveitem[3] := '1';
liveitem[6] := '1';
END;
8 : BEGIN
liveitem[3] := '0';
liveitem[6] := '0';
END;
ELSE
Closewin;
done := TRUE;
END;
END;
done := FALSE;
END;
END;
PROCEDURE Showfile;
VAR
sourcename : PATHSTR;
source : TEXT;
txtstr : STRING;
txtarray : Lstarray;
numoflns : INTEGER;
retcode : INTEGER;
PROCEDURE Addarec(s:STRING);
BEGIN
Inc(numoflns);
NEW(txtarray[numoflns]);
txtarray[numoflns]^ := s;
END;
BEGIN
numoflns := 0;
sourcename := '';
Openwin(10,20,7,41,Attr(0,7),Attr(1,7),2,Attr(7,0),1,0);
Titlewin(5,Attr(1,7),' Press Enter for Directory ');
Printcwin(2,'Enter a Text File Name to Display');
capson := TRUE;
Cursoron;
Getfield(4,10,sourcename,'S',20,0,retcode,Attr(15,1),Attr(0,7));
Cursoroff;
capson := FALSE;
Closewin;
IF retcode <> 0 THEN
BEGIN
IF sourcename[1] = #32 THEN
sourcename := Makefmenu('*.*',5,10,17,Attr(1,7),Attr(1,7),2,Attr(7,0),1,0,Attr(7,1));
IF sourcename <> '' THEN
BEGIN
IF Fexists(sourcename) THEN
BEGIN
ASSIGN(source,sourcename);
RESET(source);
MARK(heaptop);
REPEAT
{$I-} READLN(source,txtstr); {$I+}
IF IORESULT = 0 THEN
BEGIN
IF LENGTH(txtstr) > 76 THEN
BEGIN
msg := COPY(txtstr,1,76);
Addarec(msg);
msg := COPY(txtstr,77,LENGTH(txtstr)-76);
Addarec(msg);
END
ELSE Addarec(txtstr);
END;
UNTIL EOF(source);
CLOSE(source);
sourcename := Fexpand(sourcename);
Openwin(1,1,25,80,Attr(7,0),Attr(15,1),0,0,0,0);
Titlewin(1,Attr(15,1),'LIST DEMO');
Titlewin(3,Attr(15,1),sourcename);
Titlewin(5,Attr(15,1),'Direction Keys to Change Location - Esc or Return to End');
x := Makelmenu(txtarray,numoflns,1,Attr(0,7));
Closewin;
RELEASE(heaptop);
END
ELSE
BEGIN
Openwin(10,20,5,40,Attr(15,4),Attr(15,4),2,Attr(7,0),1,0);
Printcwin(2,'FILE NOT FOUND - PROCEDURE ABORTED!');
Continue;
Closewin;
END;
END;
END;
END;
PROCEDURE Ddemo;
VAR
dirinfo : SEARCHREC;
BEGIN
Openwin(1,1,24,80,Attr(7,1),Attr(7,1),0,0,0,0);
WRITELN;
WRITELN;
WRITELN;
WRITELN(' The following is a sampling of the DOS functions available');
WRITELN(' in TW200. For a better understanding of how to use the');
WRITELN(' information returned by these functions consult any of the');
WRITELN(' reference books on DOS interrupts. You must have a good');
WRITELN(' understanding of DOS interrupts to take full advantage of');
WRITELN(' these utilities.');
Continue;
CLRSCR;
GOTOXY(1,1);
WRITELN(' THE DEFAULT DRIVE IS ',Curdrive);
WRITELN;
WRITELN(' THE CURRENT DIRECTORY PATH IS ',Curdir);
WRITELN;
WRITELN(' FILES in THIS DIRECTORY ARE:');
WRITELN;
Findfirst('*.*'+#0,$20,dirinfo);
WRITE(Falign(dirinfo.name),' ');
WHILE doserror = 0 DO
BEGIN
Findnext(dirinfo);
WRITE(Falign(dirinfo.name),' ');
END;
WRITELN;
WRITELN;
WRITELN(' THE CURRENT DOS VERSION IS ',LO(Dosversion),'.',HI(Dosversion));
WRITELN(' CURRENT DISK SIZE ',Disksize(0):20);
WRITELN(' DISK SPACE AVAILABLE ',Diskfree(0):20);
WRITELN(' CONV MEMORY SIZE ',Maxmem:20);
WRITELN(' AVAILABLE MEMORY ',MEMAVAIL:20);
Continue;
Closewin;
END;
PROCEDURE Idemo;
CONST
info : ARRAY[1..3] OF fldtype
= ('N0221092',
'N0324062',
'N0426040');
VAR
done : BOOLEAN;
loandata : ARRAY[1..3] OF fldstr;
amount,
rate,
payment : REAL;
wfield,
month,
returncode,
errcode : INTEGER;
PROCEDURE Helpmessage(what:INTEGER);
VAR
ch1,ch2 : CHAR;
BEGIN
Openwin(6+what,38,8,36,Attr(0,2),Attr(0,2),2,8,1,0);
Sprint(6+what,38,#17,Attr(0,2));
CASE what OF
1 : BEGIN
Titlewin(2,Attr(15,2),'[ Principal Amount ]');
Printwin(1,2,'Enter the amount of the loan you');
Printwin(2,2,'wish to calulate. The format is');
Printwin(3,2,'######.##. do not enter a');
Printwin(4,2,'negative number.');
END;
2 : BEGIN
Titlewin(2,Attr(15,2),'[ Interest Rate ]');
Printwin(1,2,'Enter the interest rate for the');
Printwin(2,2,'the loan you wish to calculate.');
Printwin(3,2,'The format is ##.##. Where 11%');
Printwin(4,2,'would be entered as 11.00. do');
Printwin(5,2,'not enter a negative number.');
END;
3 : BEGIN
Titlewin(2,Attr(15,2),'[ No. of Payments ]');
Printwin(1,2,'Enter the number of payments for');
Printwin(2,2,'the loan you wish to calulate.');
Printwin(3,2,'The format is ####. Enter the');
Printwin(4,2,'actual number of payments not the');
Printwin(5,2,'number of years. do not enter a');
Printwin(6,2,'negative number.');
END;
END;
Titlewin(5,Attr(15,2),' Press any key to continue ');
Getkey(ch1,ch2);
Closewin;
END;
PROCEDURE Errmsg(what:INTEGER);
VAR
ch1,ch2 : CHAR;
BEGIN
Openwin(13,44,5,32,Attr(15,4),Attr(15,4),1,8,1,0);
CASE what OF
3 : BEGIN
Printcwin(1,'YOU MUST PROVIDE INPUT');
Printcwin(2,'FOR ALL THREE FIELDS');
Printcwin(3,'Press any key to continue ');
END;
END;
Getkey(ch1,ch2);
Closewin;
END;
PROCEDURE Computepayment(amt,rt:REAL;mo:INTEGER);
VAR
hold : REAL;
BEGIN
IF (amt > 0.0) AND (mo > 0) AND (rt > 0.0) THEN
BEGIN
hold := Powerof(1.0 + rt / 1200.0, mo);
payment := ((rt / 1200.0) * hold * amt) / (hold - 1.0);
payment := payment + 0.005;
hold := FRAC(payment * 100.0);
payment := ((payment * 100.0)-hold)/100.0;
GOTOXY(21,5);
WRITE(payment:9:2);
END
ELSE Errmsg(3);
END;
BEGIN
FILLCHAR(loandata,SIZEOF(loandata),#0);
month := 0;
rate := 0;
amount := 0;
Openwin(5,7,14,32,Attr(0,3),Attr(0,3),2,8,1,0);
Titlewin(2,Attr(15,3),'[ Payment Calculator ]');
Titlewin(5,Attr(15,3),'[ Esc - Exit ]');
Printwin(2,2,'Principal Amount:');
Printwin(3,2,' Interest Rate:');
Printwin(4,2,' No. of Payments:');
Printwin(5,2,' Payment:');
Printcwin(7, 'F1 - Help ');
Printcwin(8, 'F2 - Calculate Payment');
Printcwin(9, 'F5 - Pop-up Calculator');
done := FALSE;
wfield := 1;
WHILE NOT done DO
BEGIN
IF amount = 0 THEN loandata[1] := '' ELSE STR(amount:9:2,loandata[1]);
IF rate = 0 THEN loandata[2] := '' ELSE STR(rate:9:2,loandata[2]);
IF month = 0 THEN loandata[3] := '' ELSE STR(month:4,loandata[3]);
Cursoron;
REPEAT
Getrec(info,loandata,3,returncode,wfield,TRUE,Attr(3,0),Attr(0,3))
UNTIL returncode IN [0,59,60,63];
Cursoroff;
VAL(loandata[1],amount,errcode);
VAL(loandata[2],rate,errcode);
VAL(loandata[3],month,errcode);
CASE returncode OF
0 : done := TRUE;
59 : Helpmessage(wfield);
60 : Computepayment(amount,rate,month);
63 : Calculator(5,49,Attr(15,5),1);
END;
END;
Closewin;
END;
PROCEDURE Edemo;
BEGIN
Openwin(2,46,7,22,Attr(0,7),Attr(0,7),1,8,1,0);
done := FALSE;
WITH emenu DO
BEGIN
WHILE NOT done DO
BEGIN
Makevmenu(emenu);
CASE curntpos OF
1 : BEGIN
Openwin(8,8,10,65,Attr(15,5),Attr(15,5),2,0,1,0);
Printcwin(3,'Windows can be popped');
Printcwin(4,'onto the screen.');
DELAY(2000);
Openwin(5,5,10,50,Attr(0,2),Attr(14,2),2,7,1,0);
DELAY(2000);
Openwin(13,15,10,60,Attr(1,3),Attr(15,3),3,7,1,0);
DELAY(2000);
Openwin(7,33,10,45,Attr(14,5),Attr(14,5),1,7,1,0);
Continue;
FOR x := 1 TO 4 DO
BEGIN
Closewin;
END;
END;
2 : BEGIN
Openwin(8,8,10,65,Attr(15,5),Attr(15,5),2,0,1,0);
Printcwin(3,'Windows can be zoomed');
Printcwin(4,'onto the screen.');
DELAY(2000);
Openwin(5,5,10,50,Attr(0,2),Attr(14,2),2,7,1,1);
DELAY(2000);
Openwin(13,15,10,60,Attr(1,3),Attr(15,3),3,7,1,1);
DELAY(2000);
Openwin(7,33,10,45,Attr(14,5),Attr(14,5),1,7,1,1);
DELAY(2000);
Openwin(7,20,12,40,Attr(15,4),Attr(14,4),2,7,1,1);
Printcwin(5,'HOW ABOUT THAT !!!');
Continue;
FOR x := 1 TO 5 DO
BEGIN
Closewin;
END;
END;
3: Showfile;
4: Ddemo;
5: Idemo;
ELSE
Closewin;
done := TRUE;
END;
END;
done := FALSE;
END;
END;
BEGIN
curattr := Textattr;
Cursoroff;
Initmenus;
Openwin(1,1,25,80,Attr(0,7),Attr(0,7),0,0,0,0);
Fakewin(2,1,23,80,Attr(7,1),Attr(7,1),1,0,0,0);
Openwin(5,20,11,40,Attr(0,7),Attr(1,7),2,8,1,0);
Printcwin(2,'TW200');
CASE Curdisplay OF
0 : msg := 'MONO';
1 : msg := 'CGA';
2 : msg := 'EGA';
3 : msg := 'MCGA';
4 : msg := 'VGA';
END;
STR(lastmode:3,msg1);
msg := msg + ' monitor in video mode'+msg1;
Printcwin(3,msg);
IF Mousehere THEN msg := 'Mouse present and active.' ELSE msg := 'No mouse present';
Printcwin(4,msg);
Printcwin(5,'Copyright (C) 1990');
Printcwin(6,'by Richard D. Fothergill');
Printcwin(7,'All Rights Reserved');
x := 0;
WHILE NOT KEYPRESSED AND (x < 25000) DO Inc(x);
Closewin;
IF KEYPRESSED THEN ch := Readkey;
Sprint(25,1,' Use arrow keys to change selection - Return to select ',Attr(0,3));
done := FALSE;
WITH mmenu DO
BEGIN
WHILE NOT done DO
BEGIN
Makehmenu(mmenu);
CASE curntpos OF
1 : Fdemo;
2 : Tdemo;
3 : Sdemo;
4 : Edemo;
ELSE
Closewin;
Openwin(9,16,8,52,Attr(0,7),Attr(1,7),2,8,1,0);
Printcwin(3,' T W ');
Printcwin(4,'2 0 0');
DELAY(3000);
Closewin;
done := TRUE;
END;
END;
END;
Cursoron;
END.